home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
forth
/
amiga
/
amigaker.arc
/
01.runtime
next >
Wrap
Text File
|
1987-12-30
|
12KB
|
324 lines
; 01.runtime
;
; Runtime procedures
;
nest move.l ip,-(rp) ;label - nest
move.l w,ip ; nest a level, used by colon
jmp (a3) ; definition
* exit ;exit a colon definition
dc.w -1
dc.l link1
link1 set *-4
dc.b $84,'exi',$80!'t'
cnop 0,2
_exit dc.l *+4
move.l (rp)+,ip
jmp (a3)
* unnest ;same as exit
dc.w -1
dc.l link1
link1 set *-4
dc.b $86,'unnes',$80!'t'
cnop 0,2
_unnest dc.l _exit+4
dodoes move.l ip,-(rp) ;label - dodoes (first nest)
move.l (sp)+,ip ; (then get address, jsr )
docreate move.l w,-(sp) ;label - docreate
jmp (a3)
doconstant move.l (w),-(sp) ;label - doconstants
jmp (a3)
* (lit) ;fetch inline long constant
dc.w -1
dc.l link0
link0 set *-4
dc.b $85,'(lit',$80!')'
cnop 0,2
_nest_lit dc.l *+4
move.l (ip)+,-(sp)
jmp (a3)
* branch ;jump to the inline address
dc.w -1
dc.l link2
link2 set *-4
dc.b $86,'branc',$80!'h'
cnop 0,2
_branch dc.l *+4
bran1 move.l (ip),ip
jmp (a3)
* ?branch ;take the branch if tos is
dc.w -1
dc.l link3 ; false otherwise continue
link3 set *-4 ; note. it is the opposite
dc.b $87,'?branc',$80!'h' ; of what it is used for,
cnop 0,2 ; logically that is.
_question_branch dc.l *+4
tst.l (sp)+
beq.s bran1
addq.l #4,ip
jmp (a3)
* (loop) ;dictionary:(do)|cc|...|(loop)|bb|
; ^bb ^cc
dc.w -1
dc.l link0
link0 set *-4
dc.b $86,'(loop',$80!')'
cnop 0,2
_nest_loop dc.l *+4 ;runtime for LOOP
addq.l #1,(rp) ;loops are 32 bits also
bvc.s bran1
loop_end addq.l #8,rp ;get rid off start/index
addq.l #4,rp ;and drop the leave address
addq.l #4,ip ;jump over DO address
jmp (a3)
* (+loop)
dc.w -1
dc.l link0
link0 set *-4
dc.b $87,'(+loop',$80!')'
cnop 0,2
_nest_plus_loop dc.l *+4 ;runtime for +loop
move.l (sp)+,d0 ;plus parameter can be any
add.l d0,(rp) ; size up to 2^32
bvc.s bran1
bra.s loop_end ;same as above
* (do) ; (s limit initial -- )
dc.w -1
dc.l link0
link0 set *-4
dc.b $84,'(do',$80!')'
cnop 0,2
_nest_do dc.l *+4 ;runtime for do
movem.l (sp)+,d0-d1 ;d0=initial d1=limit
pdo move.l (ip)+,-(rp)
add.l #$80000000,d1 ;have to add to make bvc work
move.l d1,-(rp) ;store adjusted length
sub.l d1,d0
move.l d0,-(rp) ;index
jmp (a3)
* (?do) ; (s limit initial -- ) same as do but will not start
dc.w -1
dc.l link0 ; if initial=limit
link0 set *-4
dc.b $85,'(?do',$80!')'
cnop 0,2
_nest_question_do dc.l *+4
movem.l (sp)+,d0-d1
cmp.l d0,d1
bne.s pdo
bra bran1
* bounds ; (s addr len -- lim first )
dc.w -1
dc.l link2
link2 set *-4
dc.b $86,'bound',$80!'s'
cnop 0,2
_bounds dc.l *+4
move.l (sp)+,d0
move.l (sp),d1
add.l d0,(sp)
move.l d1,-(sp)
jmp (a3)
* execute ; (s cfa -- ) execute the word whose code field
; address is on the stack
dc.w -1
dc.l link1
link1 set *-4
dc.b $87,'execut',$80!'e'
cnop 0,2
_execute dc.l *+4
move.l (sp)+,w
move.l (w)+,a0
jmp (a0)
* perform ; (s addr of cfa -- ) the address of the cfa is
dc.w -1
dc.l link0 ; on the stack
link0 set *-4
dc.b $87,'perfor',$80!'m'
cnop 0,2
_perform dc.l *+4
move.l (sp)+,w
dodefer move.l (w)+,w ;label - dodefer
move.l (w)+,a0
jmp (a0)
* go ; (s addr -- ) execute code at the address
dc.w -1
dc.l link3
link3 set *-4
dc.b $82,'g',$80!'o'
cnop 0,2
_go dc.l *+4
rts
* noop ; (s -- ) Do nothing
dc.w -1
dc.l link2
link2 set *-4
dc.b $84,'noo',$80!'p'
cnop 0,2
_noop dc.l *+4
jmp (a3)
* i ; (s -- n ) Return the current loop index.
dc.w -1
dc.l link1
link1 set *-4
dc.b $81,$80!'i'
cnop 0,2
_i dc.l *+4
move.l (rp),d0
add.l 4(rp),d0
move.l d0,-(sp)
jmp (a3)
* j ; (s -- n ) Return the index of the inner loop
dc.w -1
dc.l link2
link2 set *-4
dc.b $81,$80!'j'
cnop 0,2
_j dc.l *+4
move.l 12(rp),d0
add.l 16(rp),d0
move.l d0,-(sp)
jmp (a3)
* (leave) ; (s -- ) Exit a loop immediately
dc.w -1
dc.l link0
link0 set *-4
dc.b $87,'(leave',$80!')'
cnop 0,2
_nest_leave dc.l *+4
pleave addq.l #8,rp ;get rid off start/index
move.l (rp)+,ip
jmp (a3)
* (?leave) ; (s f -- ) Exit loop if True
dc.w -1
dc.l link0
link0 set *-4
dc.b $88,'(?leave',$80!')'
cnop 0,2
_nest_question_leave
dc.l *+4
tst.l (sp)+
bne.s pleave
jmp (a3)
* @ ; (s addr -- n ) fetch value (32bit) at address
dc.w -1
dc.l link0
link0 set *-4
dc.b $81,$80!'@'
cnop 0,2
_fetch dc.l *+4
move.l (sp),a0
move.l (a0),(sp)
jmp (a3)
* ! ; (s addr n -- ) Store value n at address
dc.w -1
dc.l link1
link1 set *-4
dc.b $81,$80!'!'
cnop 0,2
_store dc.l *+4
move.l (sp)+,a0
move.l (sp)+,(a0)
jmp (a3)
* w@ ; (s addr -- wn ) Fetch 16bit value from address
dc.w -1
dc.l link3
link3 set *-4
dc.b $82,'w',$80!'@'
cnop 0,2
_w_fetch dc.l *+4
clr.l d0
move.l (sp),a0
move.w (a0),d0
move.l d0,(sp)
jmp (a3)
* w! ; (s addr wn -- ) Store 16bit value at address
dc.w -1
dc.l link3
link3 set *-4
dc.b $82,'w',$80!'!'
cnop 0,2
_w_store dc.l *+4
move.l (sp)+,a0
move.l (sp)+,d0
move.w d0,(a0)
jmp (a3)
* c@ ; (s addr -- c ) Fetch character at address
dc.w -1
dc.l link3
link3 set *-4
dc.b $82,'c',$80!'@'
cnop 0,2
_c_fetch dc.l *+4
clr.l d0
move.l (sp),a0
move.b (a0),d0
move.l d0,(sp)
jmp (a3)
* c! ; (s addr c -- ) Store character at address
dc.w -1
dc.l link3
link3 set *-4
dc.b $82,'c',$80!'!'
cnop 0,2
_c_store dc.l *+4
move.l (sp)+,a0
move.l (sp)+,d0
move.b d0,(a0)
jmp (a3)
* cmove ; (s from to count -- ) byte move from low to high addr
dc.w -1
dc.l link3
link3 set *-4
dc.b $85,'cmov',$80!'e'
cnop 0,2
_cmove dc.l *+4
movem.l (sp)+,d0/a0-a1
bra.s cmove3
cmove move.b (a1)+,(a0)+
cmove3 dbra d0,cmove
jmp (a3)
* cmove> ; (s from to count -- ) byte move from high to low addr
dc.w -1
dc.l link3
link3 set *-4
dc.b $86,'cmove',$80!$3e
cnop 0,2
_cmove_up dc.l *+4 ;NOTE: only 16bit length!!
movem.l (sp)+,d0/a0-a1 ; or max 2^16
cmove1 add.l d0,a0 ;ALSO: cmove1 is jumped to
add.l d0,a1 ; by ROLL.
bra.s cmove4
cmove2 move.b -(a1),-(a0)
cmove4 dbra d0,cmove2
jmp (a3)